Unit ATTR_WIN;

(* Incudes MAXVAR,MAXIEEE,MAXUTIL,MAXDBF,MAXNDX,MAXEVAL,MAXCMP *)

(************************************************************************
 *                                                                      *
 *    MAXVAR . P A S        Turbo Pascal 4.0 dBase III+ Unit            *
 *       Interface           With Pascal Versions of Library Functions  *
 *    Copyright May 1988     Max Software Consultants, Inc              *
 *                                                                      *
 ************************************************************************)

                          {  U N I T    MAXVAR    }


Interface

Uses Windos,Objects, WinTypes, WinProcs, Strings,
     CARTOCmds,
     tit_win,get_win,gmuf_win,aux_win,max_win;

(* Interface Attributes *)
(*
procedure export_pol(nuk:integer; nomout:string);
procedure import_pol(nuk:integer; nomin:string);
*)
IMPLEMENTATION

(* Interface attributes *)

(*
procedure export_pol(nuk:integer; nomout:string);

label 999;

var   erreur,ier,l,k,n,val,option,nb,posy,curcode:integer;
      hist:phisto;
      rc,caret:char;
      etable:pptable;
      etiq,newlab:st10;
      h_tot : real;

      strn,strh1,strh2:string;

      { CREATE DPSAM.DBF }
      { ADD RECORDS TO DPSAM.DBF }

Var

   dName       :   string;
   Flds        :   pFields;
   i           :   integer;
   FName       :   array[1..2] of Str10;
   FType       :   array[1..2] of Char;
   W           :   array[1..2] of FldWidth;
   D           :   array[1..2] of FldDec;
   Error       :   string;

   STATUS_DBF    : INTEGER;

   dbf         :   dFile;
   Code        :   Integer;
   Attribute   :   string[9];
   CodeStr     :   String;
   Strl        :   Integer;
   X           :   Char;
   Buffer      :   Array [1..13] of char;

   Label           Abort;

{$I DPER_INC.PAS}

begin

  hist := nil; etable := nil; Flds := nil;
  ier := _getmem('-',pointer(hist),sizeOf(histo));
  if ier <> 0 then goto 999;
  ier := _getmem('-',pointer(etable),sizeOf(ptable));
  if ier <> 0 then goto 999;
  ier := _getmem('-',pointer(Flds),sizeOf(Fields));
  if ier <> 0 then goto 999;

  ier := rhisto(nuk,gmf,hist^);
  if ier <> 0 then goto 999;
  for n := 0 to 255 do etable^[n] := '';
  if gmk.prm[7] > 0 then ier := rlpol(nuk,gmf,etable^)
    else goto 999;

  h_tot := 0;
  for n := 0 to 255 do h_tot := h_tot + hist^[n];
  nb := 0;

   FName [1] := 'CODE';
   FName [2] := 'ATTRIBUTE';
   FType [1] := 'N';
   FType [2] := 'C';
   W     [1] :=   3;
   W     [2] :=   9;
   D     [1] :=   0;
   D     [2] :=   0;

   dName := copy(nomout,1,length(nomout));

   Result := Success;
   for i := 1 to 2 do if Result = Success then
   begin
      Result := dp_BuildField(FName[i],FType[i],W[i],D[i],Flds^[i]);
      Error  := dpError(Result);
   end;

   if Result = Success then begin
      Result := dp_CreateDBF ( dName,2,Flds^);
      Error  := dpError(Result);
      if Result <> Success then begin
        WriteLn (' Can`t Create Database. ');
        goto 999;
      end;
   end else goto 999;


   Result := dp_OpenDBF(dName,dplSingle,dbf);
   Error  := dpError(Result);

  for n := 0 to 255 do begin

      if hist^[n] > 0.5 then begin

          etiq := nam10(etable^[n]);
          str(n:3,strn);
          str(hist^[n]:8:0,strh1);
          str(hist^[n]/h_tot:5:3,strh2);
{          _writeln(strn+'  '+etiq++strh1+'     '+strh2);   }
          nb := nb+1;

          Code := n;
          Attribute := copy(etiq,1,9);

          { Transfer Values to Buffer }
          FillChar(Buffer,13,0);
          Str(Code:3,CodeStr);
          Result := dp_PutValue(dbf,FName[1],X,Buffer,CodeStr);
          Error  := dpError(Result);
          Result := dp_PutValue(dbf,FName[2],X,Buffer,Attribute);
          Error  := dpError(Result);
          Result := dp_PutRec(dbf,Append,Buffer);
          Error  := dpError(Result);

      end; { End Hist[n] > 0.5 }

   end;

   Abort: Result := dp_CloseDBF(dbf);
          Error  := dpError(Result);

999:
  _freemem('-',pointer(Flds),sizeof(Fields));
  _freemem('-',pointer(hist),sizeof(histo));
  _freemem('-',pointer(etable),sizeof(ptable));
end;

procedure import_pol(nuk:integer; nomin:string);
var   erreur,ier,l,k,n,nn,option,nb,posy,curcode:integer;
      etable,dbtable:pptable;
      code_table:pitable;
      etiq,newlab:st10;

      { CREATE DPSAM.DBF }
      { ADD RECORDS TO DPSAM.DBF }

Var

   dName       :   str255;
   Flds        :   pFields;
   i           :   integer;
   FName       :   array[1..15] of Str10;
   FType       :   array[1..15] of Char;
   W           :   array[1..15] of FldWidth;
   D           :   array[1..15] of FldDec;
   Error       :   str255;
   NumFlds     :   integer;
   Total       :   integer;
   REcNum      :   RecNr;

   STATUS_DBF    : INTEGER;

   dbf         :   dFile;
   Code        :   Integer;
   CodeStr     :   Str255;
   Code_ind    :   Integer;
   Attribute   :   polab;
   Attrib_ind  :   Integer;
   Strl        :   Integer;
   X           :   Char;
   Buffer      :   Array [1..256] of char;
   Label           Abort;

{$I DPER_INC.PAS}

label 999;

Function OpenForInfo(dName:str255;Var dbf:dFile;Var Flds:Fields): integer;
Var
   Error        : str255;
   RecordLength : integer;
   Day,Month    : byte;
   Year         : byte;
   FldNum       : integer;
begin
   Result := dp_GetInfo( dbf, RecordLength, Day, Month, Year, FldNum, Flds );
   Error  := dpError(Result);
   OpenForInfo := FldNum;
end;

begin

  code_table := nil; dbtable := nil; etable := nil; Flds := nil;
  ier := _getmem('-',pointer(dbtable),sizeOf(ptable));
  if ier <> 0 then goto 999;
  ier := _getmem('-',pointer(code_table),sizeOf(itable));
  if ier <> 0 then goto 999;
  ier := _getmem('-',pointer(etable),sizeOf(ptable));
  if ier <> 0 then goto 999;
  ier := _getmem('-',pointer(Flds),sizeOf(Fields));
  if ier <> 0 then goto 999;

   dName := copy(nomin,1,length(nomin));

   Result := Success;
   Result := dp_OpenDBF(dName,dplSingle,dbf);
   Error  := dpError(Result);

   NumFlds := OpenForInfo (dName, dbf, Flds^);
   if Numflds > 15 then goto 999;

   Attrib_ind := 0;
   Code_ind := 0;

   Total := 0;
   For i := 1 to NumFlds do
   begin
      With Flds^[i] do
      begin
         str(i:5,strw);
         _Write (strw+'  '+FieldNm+dp_Strng(' ',12-Length(FieldNm)));
         Case dType of
            'C' : begin
                    _Write ('Character');
                  end;
            'N' : _Write ('Numeric  ');
            'D' : _Write ('Date     ');
            'L' : _Write ('Logical  ');
            'M' : _Write ('Memo     ');
         end; { Case }
         str(Width:7,strw);
         _Write (strw);

         if (FieldNm = 'ATTRIBUTE') AND (dType = 'C') AND (Width = 9) then
             Attrib_ind := i;
         if (FieldNm = 'CODE') AND (dType = 'N') AND (Width = 3) AND (Dec = 0) then
             Code_ind := i;

         str(Dec:7,strw);
         if dType = 'N' then _Write(strw);
         _WriteLn('');
         Total := Total + Width;
         if Total > 256 then goto 999;

             FName[i] := FieldNm;
             Ftype[i] := dType;
             W[i] := Width;
             D[i] := Dec;

      end; { With }
   end;
   if (Attrib_ind = 0) OR (Code_ind = 0) then goto 999;

   for n := 0 to 255 do dbtable^[n] := '$$$$$$$$$';
   nb :=0;

       REPEAT

         nb := nb+1;

         FillChar(Buffer,255,0);
         Result := Success;
         RecNum := nb;
         RESULT := DP_GETREC(DBF,RecNum,BUFFER,STATUS_DBF);
         Error := DPERROR(RESULT);

         if result = success then begin

           RESULT := DP_VALUE(DBF,FName[Attrib_ind],X,BUFFER,Attribute);
           Error := DPERROR(RESULT);
           dbtable^[nb-1] := copy(Attribute,1,9);
           RESULT := DP_VALUE(DBF,FName[Code_ind],X,BUFFER,CodeStr);
           Error := DPERROR(RESULT);
           Val(CodeStr,code_table^[nb-1],ier);
           str(nb,strw);
           _writeln('Db import '+strw+' '+CodeStr+'  '+dbtable^[nb-1]);
         end;

       UNTIL (RESULT <> SUCCESS);

   Abort: Result := dp_CloseDBF(dbf);
          Error  := dpError(Result);
          nb := nb-1;

  for n := 0 to 255 do etable^[n] := '';

  for n := 1 to nb do begin
    if (code_table^[n-1] > -1) AND (code_table^[n-1] < 256) then begin
      etable^[code_table^[n-1]] :=  dbtable^[n-1];
    end;
  end;

  ier := wlpol(nuk,gmf,etable^);

999:
   _freemem('-',pointer(Flds),sizeof(Fields));
   _freemem('-',pointer(etable),sizeof(ptable));
   _freemem('-',pointer(dbtable),sizeof(ptable));
   _freemem('-',pointer(code_table),sizeof(itable));
end;
*)
END.
